(module core mzscheme
  (require-for-syntax "metadata.scm")
  (require-for-syntax "types/types.scm")
  (require-for-syntax "types/type-sugar.scm")

  (require (only (lib "1.ss" "srfi") car+cdr))
    
  (provide list-match)
  ;; Useful macro for matching on a list.  Basically,
  ;; (list-match lst (a b c) r body ...) causes a to be bound to the first item 
  ;; in the list, b the second, c the third, and r the rest inside the 
  ;; statements within body
  (define-syntax (list-match stx)
    (syntax-case stx ()
      ((_ lst () rest body ...)
       #'(let ((rest lst)) body ...))
      ((_ lst (x y ...) rest body ...)
       #'(let-values (((x ys) (car+cdr lst)))
           (_ ys (y ...) rest body ...)))))

  (define-syntax (describe stx)
    (syntax-case stx ()
      ((_ prim) (and (identifier? #'prim) (cat-ref (syntax-e #'prim) #f))
                #`(quote #,(describe-sym (syntax-e #'prim))))))
  (provide define-cat cat-compile cat-main define-cat-prim describe)

  ;; Macro for defining new cat-primitives using scheme syntax
  (define-syntax (cat-spec stx)
    (syntax-case stx (=>)
      ;; Specify exactly the lambda expansion
      ((_ definition) #'definition)
      ;; Specify arguments and a value to hold the top
      ((_ (args ...) top => definition ...)
       (with-syntax (((pops ...)   (reverse (syntax->list #'(args ...))))
                     ((pushes ...) (reverse (syntax->list #'(definition ...)))))
         #'(lambda (s)
             (list-match s (pops ...) rest
                         (let ((top (car rest)))
                           (list* pushes ... rest))))))
      ;; Specify arguments
      ((_ (args ...) => definition ...)
       (with-syntax (((pops ...)   (reverse (syntax->list #'(args ...))))
                     ((pushes ...) (reverse (syntax->list #'(definition ...)))))
         #'(lambda (s)
             (list-match s (pops ...) rest
                         (list* pushes ... rest)))))))
  
  ;; Define a new cat primitive using a specification written in one of the forms
  ;; from cat-spec
  (define-syntax (define-cat-prim stx)
    (syntax-case stx (metadata)
      ((define-cat-prim (prim ty) (metadata meta ...) definition ...)
       (with-syntax (((prim-sym) (generate-temporaries (list (syntax-e #'prim))))
                     (md (parse-metadata #'(meta ...))))
         #'(begin (define-syntax _ (cat-extend! (quote prim) 
                                                (make-cat-func (syntax prim-sym)
                                                               (type-sugar #'ty)
                                                               md))) 
                  (provide prim-sym)
                  (define prim-sym (cat-spec definition ...)))))
      ((define-cat-prim (prim ty ...) definition ...)
       (with-syntax (((prim-sym) (generate-temporaries (list (syntax-e #'prim)))))
         #'(begin (define-syntax _ (cat-extend! (quote prim) 
                                                (make-cat-func (syntax prim-sym)
                                                               (type-sugar #'(ty ...))
                                                               default-metadata))) 
                  (provide prim-sym)
                  (define prim-sym (cat-spec definition ...)))))))

  ;; Macro for defining new cat-functions using cat syntax
  (define-syntax (define-cat stx)
    (syntax-case stx ()
      ((define-cat prim def ...)
       (with-syntax (((prim-sym) (generate-temporaries (list (syntax-e #'prim)))))
         #'(begin (define-syntax _ (cat-extend! (quote prim) 
                                                (make-cat-func (syntax prim-sym)
                                                               (make-ty-app (make-tycon-bot) ())
                                                               default-metadata)))
                  (provide prim-sym)
                  (define prim-sym (cat-compile def ...)))))))
  
  ;; Transformation from an identifier that is understood by cat into a value
  (define-syntax (cat-exp-to-value stx)
    (syntax-case stx (lst)
      ((_ (lst xs ...))
       #'(list (cat-exp-to-value xs) ...))
      ((_ (cmds ...))
       #'(cat-compile cmds ...))
      ((_ prim) (and (identifier? #'prim) (cat-ref (syntax-e #'prim) #f))
                (cat-func-id (cat-ref (syntax-e #'prim)
                                      ;; Note that this error is unreachable
                                      (lambda () (raise-syntax-error #f "undefined cat function/primitive" #'prim)))))
      ((_ other) #'other)))
      
  ;; Helper function for cat-compile.
  (define-syntax (cat-compile-helper stx)
    (syntax-case stx ()
      ((_ s) #'s)
      ((_ s prim exps ...) (and (identifier? #'prim) (cat-ref (syntax-e #'prim) #f))
       (let* ((func-info (cat-ref (syntax-e #'prim)
                                  ;; Note that this error is unreachable
                                  (lambda () (raise-syntax-error #f 
                                               "undefined cat function/primitive" #'prim))))
              (f (cat-func-id func-info)))
         #`(cat-compile-helper (#,f s) exps ...)))
      ((_ s other exps ...)
       #'(cat-compile-helper (cons (cat-exp-to-value other) s) exps ...))))
   
  (require-for-syntax "typecore.scm")
  (require-for-syntax "types/type-pprint.scm")
  (define-syntax (show-type-of stx)
    (syntax-case stx ()
      ((_ exps ...)
       #`(display (format "~S~%" #,(type->string (type-of-exp #'(exps ...))))))))
  (provide show-type-of)
  
  ;; Convert a cat-expression into a scheme function that can be applied to the
  ;; initial argument list
  (define-syntax cat-compile
    (syntax-rules ()
      ((_ exps ...)
       (lambda (s) (cat-compile-helper s exps ...)))))
  
  ;; Apply a cat-function to the empty list
  (define-syntax cat-main
    (syntax-rules ()
      ((_ code ...) ((cat-compile code ...) ())))))
